home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / eulisp / mpfeel.lha / MPFeel / Plurals / mp_io.m < prev    next >
Text File  |  1992-05-12  |  14KB  |  570 lines
  1. /*
  2.  *    Plurals
  3.  *
  4.  *    Author:    S.C.Merrall
  5.  *
  6.  *    File:    mp_io.m
  7.  *
  8.  *    Contents:    print
  9.  *            print_pair
  10.  *            print_integer
  11.  *            print_vector
  12.  *            out_of_scratch_p
  13.  *            scratch[]
  14.  *            print_symbol
  15.  *
  16.  *    Description:    Output formats for basic lisp objects to print
  17.  *            plurals out without transferring contents to the
  18.  *            front end.
  19.  *
  20.  *    Change History:
  21.  *
  22.  *    Date   Name Comment
  23.  *    -------- ---- -------
  24.  *    16:04:91 SCM  Created
  25.  *    22:04:91 SCM  Uses MasPar Plural Heap Objects instead of offsets
  26.  *    24:04:91 SCM  Added print_pair
  27.  *    14:06:91 SCM  print_lisp_object becomes print
  28.  *    15:05:91 SCM  Added print_vector and out_of_scratch_p
  29.  *    04:06:91 SCM  Size in heap_header is now in bytes, changed vectors
  30.  *    29:01:92 SCM  Started putting in support for symbols
  31.  */
  32.  
  33. #include <mpl.h>
  34. #include <stdio.h>
  35.  
  36. #include "constant.h"
  37.  
  38. #include "mp_object.h"
  39. #include "mp_debug_off.h"
  40. #include "mp_gc.h"
  41. #include "mp_utils.h"
  42. #include "mp_type.h"
  43. #include "mp_main.h"    /* THIS IS TEMPORARY */
  44.  
  45. typedef struct cons_cell_ {
  46.   natural car;
  47.   natural cdr;
  48. } cons_cell;
  49.  
  50. #define MAX_DEC_PLACES 6
  51. #define OUTPUT_SCRATCH_SIZE (2*SCRATCH_MEMORY_SIZE/3)
  52.  
  53. /*----------------------------------------------------------------------------*
  54.  * Function   : out_of_scratch_p
  55.  *
  56.  * Parameters : plural int *scratch_used:    Ammount of scratch space used
  57.  *                        so far
  58.  *
  59.  * Description:    Tests to see if we have used up more than two thirds of the
  60.  *        scratch space and if so prints some dots and returns TRUE
  61.  *        otherwise just returns FALSE
  62.  *
  63.  * Result     : plural int:    TRUE/FALSE
  64.  *---------------------------------------------------------------------------*/
  65.  
  66. #ifdef __STDC__
  67.  
  68. plural int out_of_scratch_p( plural int *scratch_used )
  69.  
  70. #else
  71.  
  72. plural int out_of_scratch_p( scratch_used )
  73.  
  74. plural int * scratch_used;
  75.  
  76. #endif
  77.  
  78. {
  79. DBG_CALL("out_of_scratch_p");
  80. DBG_ARGS(fprintf(dbg,"scratch_used=%04x",scratch_used));
  81.  
  82.   if (*scratch_used > OUTPUT_SCRATCH_SIZE) {
  83.  
  84.     scratch[(*scratch_used)++] = '.';
  85.     scratch[(*scratch_used)++] = '.';
  86.     scratch[(*scratch_used)++] = '.';
  87.  
  88. DBG_EXIT(fprintf(dbg,"TRUE"));
  89.     return TRUE;
  90.   }
  91.  
  92. DBG_EXIT(fprintf(dbg,"FALSE"));
  93.   return FALSE;
  94. }
  95.     
  96. /*----------------------------------------------------------------------------*
  97.  * Function   : print_pair
  98.  *
  99.  * Parameters : plural char *plural data:    Where the cons cells are living
  100.  *        plural int scratch_used:    Where to write to in scratch
  101.  *
  102.  * Description:    Writes usual representation of a cons cell to the indicated
  103.  *        position in scratch
  104.  *
  105.  * Result     : plural int: New value of scratch_used
  106.  *---------------------------------------------------------------------------*/
  107.  
  108. #ifdef __STDC__
  109.  
  110. plural int print_pair( plural char *plural data, plural int scratch_used )
  111.  
  112. #else
  113.  
  114. plural int print_pair( data, scratch_used )
  115.  
  116. plural char *plural data;
  117. plural int scratch_used;
  118.  
  119. #endif
  120.  
  121. {
  122.   plural cons_cell pair;         /* The pairs to be printed */
  123.   plural natural car, cdr;
  124.   MP_PluralHeap MPPH_car;    /* MasPar Plural Heap objects, where */
  125.   MP_PluralHeap MPPH_cdr;    /* the car and cdr heap space is     */
  126.  
  127. DBG_CALL("print_pair");
  128. DBG_ARGS(fprintf(dbg,"data=????, scratch_used=????"));
  129.  
  130.   if (scratch_used > OUTPUT_SCRATCH_SIZE) {
  131.  
  132.     scratch[scratch_used++] = '.';
  133.     scratch[scratch_used++] = '.';
  134.     scratch[scratch_used++] = '.';
  135.  
  136. DBG_EXIT(fprintf(dbg,"Exceeded scratch space"));
  137.     return scratch_used;
  138.   }
  139.  
  140.   pair = *(plural cons_cell *plural) data;
  141.  
  142.   OA_to_offsets(MPPH_car) = &(pair.car);
  143.   OA_to_offsets(MPPH_cdr) = &(pair.cdr);
  144.  
  145.   scratch_used = print(MPPH_car, scratch_used);
  146.  
  147.   if (OA_offsets(MPPH_cdr) != NIL) {
  148.  
  149.     scratch[scratch_used++] = ' ';
  150.  
  151.     if (OA_info(MPPH_cdr) == MP_CONS)
  152.       scratch_used = print_pair( OA_data(MPPH_cdr), scratch_used );
  153.     
  154.     else {
  155.  
  156.       scratch[scratch_used++] = '.';
  157.       scratch[scratch_used++] = ' ';
  158.  
  159.       scratch_used = print(MPPH_cdr, scratch_used);
  160.     }
  161.   }
  162.  
  163. /*  scratch[scratch_used++] = ')';
  164.   scratch[scratch_used] = NULL; */
  165.  
  166. DBG_EXIT(fprintf(dbg,"scratch_used=????"));
  167.   return scratch_used;
  168. }
  169.  
  170. /*----------------------------------------------------------------------------*
  171.  * Function   : print_vector
  172.  *
  173.  * Parameters : plural char *plural data:    Where the vectors are living
  174.  *              plural int *plural length:      The lengths of the vectors
  175.  *        plural int scratch_used:    Where to write to in scratch
  176.  *
  177.  * Description:    Writes a vector in the usual format to the indicated 
  178.  *        posistion in scratch
  179.  *
  180.  * Result     : plural int:    New value of scratch_used
  181.  *---------------------------------------------------------------------------*/
  182.  
  183. #ifdef __STDC__
  184.  
  185. plural int print_vector( plural char *plural data,
  186.              plural int length,
  187.              plural int scratch_used )
  188.  
  189. #else
  190.  
  191. plural int print_vector( data, length, scratch_used )
  192.  
  193. plural char *plural data;
  194. plural int length;
  195. plural int scratch_used;
  196.  
  197. #endif
  198.  
  199. {
  200.   plural int i;
  201.   plural natural *plural vector;    /* The vectors to be printed        */
  202.   plural natural element;
  203.   MP_PluralHeap MPPH_elt;    /* masPar Plural Heap object, where */
  204.                     /* the element heap space is        */
  205.  
  206. DBG_CALL("print_vector");
  207. DBG_ARGS(fprintf(dbg,"data=????, scratch_used=????"));
  208.  
  209. DEBUG(fprintf(dbg,"length: ");)
  210. DEBUG(p_fprintf(dbg," %d",length);)
  211. DEBUG(fprintf(dbg,"\n");)
  212.  
  213.   scratch[scratch_used++] = '#';
  214.   scratch[scratch_used] = '(';
  215.  
  216.   vector = (plural natural *plural) data;
  217.  
  218.   for (i=0; i<length; ++i) {            /* Print Lisp Object in each element */
  219.  
  220.     ++scratch_used;
  221.  
  222.     if (out_of_scratch_p(&scratch_used)) {
  223.  
  224. DBG_EXIT(fprintf(dbg,"Exceeded scratch space"));
  225.       return scratch_used;
  226.     }
  227.  
  228.     element = vector[i];
  229.     OA_to_offsets(MPPH_elt) = &element;
  230.     scratch_used = print(MPPH_elt, scratch_used);
  231.     scratch[scratch_used] = ' ';
  232.   }
  233.   
  234.   scratch[scratch_used++] = ')';
  235.   scratch[scratch_used] = NULL;
  236.  
  237. DBG_EXIT(fprintf(dbg,"scratch_used=????"));
  238.   return scratch_used;
  239. }
  240.     
  241.  
  242. /*----------------------------------------------------------------------------*
  243.  * Function   : print_integer
  244.  *
  245.  * Parameters : plural char *plural data:        Where the integers are living
  246.  *              plural int scratch_used:         Where to write to in scratch
  247.  *
  248.  * Description:    writes decimal reprentation of numbers pointed to into
  249.  *              given location in scartch memory
  250.  *
  251.  * Result     : plural int: new values of scratch_used
  252.  *---------------------------------------------------------------------------*/
  253.  
  254. #ifdef __STDC__
  255.  
  256. plural int print_integer( plural char *plural data, plural int scratch_used )
  257.  
  258. #else
  259.  
  260. plural int print_integer( data, scratch_used )
  261.  
  262. plural char *plural data;
  263. plural int scratch_used;
  264.  
  265. #endif
  266.  
  267. {
  268.   plural int integer;        /* The integers to be printed     */
  269.   plural int i;              /* power of 10 for finding digits */
  270.   plural int digit;          /* individual digit of decimal    */
  271.   plural int digits;         /* length of numbers              */
  272.  
  273. DBG_CALL("print_integer");
  274. DBG_ARGS(fprintf(dbg,"data=????, scratch_used=????"));
  275.  
  276.   integer = *(plural int *plural) data;
  277.   
  278.   if (integer < 0) {
  279.  
  280.     scratch[scratch_used++] = '-';
  281.     integer = -integer;
  282.   }
  283.   digits = 0;
  284.  
  285.   do {
  286.  
  287.     digit = integer%10;
  288.     integer = integer/10;
  289.  
  290.     ++digits;
  291.     scratch[SCRATCH_MEMORY_SIZE - digits] = '0' + digit;
  292.  
  293.   } while (integer > 0);
  294.  
  295.   pp_memcpy((plural char *plural) &scratch[scratch_used],
  296.         (plural char *plural) &scratch[SCRATCH_MEMORY_SIZE - digits],
  297.         digits );
  298.  
  299.   scratch_used = scratch_used + digits;
  300.                    
  301.   scratch[scratch_used] = NULL;
  302.  
  303. DBG_EXIT(fprintf(dbg,"????"));
  304.   return scratch_used;
  305. }
  306.  
  307. /*----------------------------------------------------------------------------*
  308.  * Function   : print_float
  309.  *
  310.  * Parameters : plural char *plural data:    The floats to be printed
  311.  *        plural int scratch_used:    Where in scartch space to
  312.  *                        print floats.
  313.  *
  314.  * Description:    Writes decimal representation of numbers into the
  315.  *        scratch space at the position indicated.
  316.  *
  317.  * Result     : plural int:    New value of scratch_used
  318.  *---------------------------------------------------------------------------*/
  319.  
  320. #ifdef __STDC__
  321.  
  322. plural int print_float( plural char *plural data, plural int scratch_used )
  323.  
  324. #else
  325.  
  326. plural int print_float( data, scratch_used )
  327.  
  328. plural char *plural data;
  329. plural int scratch_used;
  330.  
  331. #endif  
  332.  
  333. {
  334.   plural float real;
  335.   plural float original = 0.0;
  336.   plural float printed = 0.0;
  337.   plural int scratch_start;
  338.   plural int places = 0;
  339.   plural int digit;
  340.   plural int printed_point = FALSE;
  341.   plural float power;
  342.  
  343. DBG_CALL("print_float");
  344. DBG_ARGS(fprintf(dbg,"data=????, scratch_used=????"));
  345.  
  346.   if (out_of_scratch_p(&scratch_used)) {
  347.  
  348. DBG_EXIT(fprintf(dbg,"Exceeded scratch space"));
  349.     return scratch_used;
  350.   }
  351.  
  352.   real = *(plural float *plural) data;
  353.   if (real < 0.0) {
  354.     
  355.     scratch[scratch_used++] = '-';
  356.     real = -real;
  357.   }
  358.   original = real;
  359.  
  360.   /* find power of 10 greater than number */
  361.  
  362.   for (power = (plural float) 1.0; (10.0*power) <= real; power = power * 10.0);
  363.  
  364.   while ((places != MAX_DEC_PLACES) && 
  365.      ((printed != original) || (power > 0.1))) {
  366.  
  367.     digit = (plural int) (real / power);
  368.     scratch[scratch_used++] = '0' + digit;
  369.     real = real - (power * (plural float) digit );
  370.     printed = printed + (power * (plural float) digit);
  371.     power = power/10.0;
  372.  
  373.     if (power < 1.0) {
  374.  
  375.       ++places;
  376.  
  377.       if (!printed_point) {
  378.  
  379.     scratch[scratch_used++] = '.';
  380.     printed_point = TRUE;
  381.       }
  382.     }
  383.   }
  384.  
  385.   scratch[scratch_used] = NULL;
  386.   
  387. DBG_EXIT(fprintf(dbg,"????"));
  388.   return scratch_used;
  389. }
  390.  
  391.  
  392. /*----------------------------------------------------------------------------*
  393.  * Function   : print_symbol
  394.  *
  395.  * Parameters : plural char *plural data:    Where the symbols are living
  396.  *        plural int scratch_used:    Where to write to in scratch
  397.  *
  398.  * Description: Writes (at the moment) an address style repesentation of
  399.  *        a symbol, that is it prints it as it's front end address
  400.  *
  401.  * Result     : plural int:    new values of scratch
  402.  *---------------------------------------------------------------------------*/
  403.  
  404. #ifdef __STDC__
  405.  
  406. plural int print_symbol( plural char *plural data, plural int scratch_used )
  407.  
  408. #else
  409.  
  410. plural int print_symbol( data, scratch_used )
  411.  
  412. plural char *plural data;
  413. plural int scratch_used;
  414.  
  415. #endif
  416.  
  417. {
  418.   plural int ids;        /* The ids of the symbols to be printed */
  419.   int i;
  420.  
  421. DBG_CALL("print_symbols");
  422. DBG_ARGS(fprintf(dbg,"data=????, scratch_used=????"));
  423.  
  424.   if (scratch_used > OUTPUT_SCRATCH_SIZE) {
  425.  
  426.     scratch[scratch_used++] = '.';
  427.     scratch[scratch_used++] = '.';
  428.     scratch[scratch_used++] = '.';
  429.  
  430. DBG_FAIL(fprintf(dbg,"Exceeded scratch space"));
  431.     return scratch_used;
  432.   }
  433.  
  434. /*   scratch[scratch_used++] = '#';
  435.  *   scratch[scratch_used++] = '<';
  436.  *   scratch[scratch_used++] = 'i';
  437.  *   scratch[scratch_used++] = 'd';
  438.  *   scratch[scratch_used++] = '=';
  439.  *   scratch_used = print_integer( data, scratch_used );
  440.  *   scratch[scratch_used++] = '>';
  441.  *   scratch[scratch_used] = NULL;
  442.  */
  443.  
  444.   scratch[scratch_used++] = 1;
  445.   
  446.   for (i=0; i<sizeof(int); i++) scratch[scratch_used++] = *(data + i);
  447.  
  448.   scratch[scratch_used] = NULL;
  449.  
  450. DBG_EXIT(fprintf(dbg,"????"));
  451.   return scratch_used;
  452. }
  453.  
  454.  
  455. /*----------------------------------------------------------------------------*
  456.  * Function   : print
  457.  *
  458.  * Parameters : MP_PluralHeap MPPH_to_print:    MasPar Plural Heap object for plural
  459.  *                    to be printed
  460.  *              plural int scratch_used:Current positions in scratch
  461.  *
  462.  * Description: Big switch statement to print out all know lisp objects
  463.  *              Those processors which have used two thirds of the scratch
  464.  *              space print "..." and give up at this stage.
  465.  *
  466.  * Result     : int:    ammount of scratch space used
  467.  *---------------------------------------------------------------------------*/
  468.  
  469. #ifdef __STDC__
  470.  
  471. plural int print( MP_PluralHeap MPPH_to_print, plural int scratch_used )
  472.  
  473. #else
  474.  
  475. plural int print( MPPH_to_print, scratch_used )
  476.  
  477. MP_PluralHeap MPPH_to_print;
  478. plural int scratch_used;
  479.  
  480. #endif
  481.  
  482. {  
  483.   plural int type;
  484.   plural heap_header header;
  485.   plural heap_header *plural to_header;
  486.   plural natural offset;
  487. DBG_CALL("print");
  488. DBG_ARGS(fprintf(dbg,"MPPH_to_print=%04x, scratch_used=????",MPPH_to_print));
  489.  
  490.   if (scratch_used > OUTPUT_SCRATCH_SIZE) {
  491.     scratch[scratch_used++] = '.';
  492.     scratch[scratch_used++] = '.';
  493.     scratch[scratch_used++] = '.';
  494.   }
  495.  
  496.   else if (OA_offsets(MPPH_to_print) == NIL) {
  497.  
  498.     scratch[scratch_used++] = '(';
  499.     scratch[scratch_used++] = ')';
  500.     scratch[scratch_used] = NULL;
  501.  
  502.   }
  503.   else if (OA_offsets(MPPH_to_print) == NOT_NIL) {
  504.  
  505.     scratch[scratch_used++] = 't';
  506.     scratch[scratch_used] = NULL;
  507.  
  508.   }
  509.   else {
  510.  
  511.     offset = *MPPH_to_print;
  512.     type = HH_info(heap_memory[offset]);
  513.     type = HH_info(heap_memory[*MPPH_to_print]);
  514.     type = OA_info(MPPH_to_print);
  515.            
  516.     
  517.     switch (type) {
  518.  
  519.     case MP_SYMBOL:
  520.  
  521.       scratch_used = print_symbol(OA_data(MPPH_to_print), scratch_used);
  522.       break;
  523.     
  524.     case INTEGER:
  525.  
  526.       scratch_used = print_integer(OA_data(MPPH_to_print), scratch_used);
  527.       break;
  528.  
  529.     case MP_FLOAT:
  530.  
  531.       scratch_used = print_float(OA_data(MPPH_to_print), scratch_used);
  532.       break;
  533.  
  534.     case 6:
  535.  
  536.       scratch_used = print_symbol(OA_data(MPPH_to_print), scratch_used);
  537.       break;
  538.  
  539.     case MP_CONS:
  540.       
  541.       scratch[scratch_used++] = '(';
  542.       scratch_used = print_pair(OA_data(MPPH_to_print), scratch_used);
  543.       scratch[scratch_used++] = ')';
  544.       scratch[scratch_used] = NULL;
  545.       break;
  546.  
  547.     case MP_VECTOR:
  548.  
  549.       scratch_used = print_vector(OA_data(MPPH_to_print), 
  550.                   MP_LENGTH(OA_space(MPPH_to_print)), 
  551.                   scratch_used);
  552.       break;
  553.  
  554.     default:
  555.  
  556.       scratch[scratch_used++] = '?';
  557.       scratch[scratch_used++] = '?';
  558.       scratch[scratch_used++] = '?';
  559.       scratch[scratch_used] = NULL;
  560.  
  561.     }
  562.   }
  563.  
  564.  
  565.  
  566. DBG_EXIT(fprintf(dbg,"SUCCESS: ????"));
  567.   return scratch_used;
  568. }
  569.  
  570.